home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 / Aminet - June 1993 [Walnut Creek].iso / ab20 / utilitys / editors / emacs185.lha / emacs / lisp / amiga-menu.el < prev    next >
Encoding:
Text File  |  1992-01-03  |  1.6 KB  |  53 lines
  1. ;(provide 'amiga-menu)
  2.  
  3. (defvar amiga-menus-description nil
  4.   "Variable containing the menus setup for Emacs")
  5.  
  6. (defun amiga-menus-set (menus)
  7.   "Setup menus for emacs (parameter as for amiga-menus)"
  8.   (define-key mouse-map amiga-button-right-up 'amiga-menus-dispatch)
  9.   (setq amiga-menus-description menus)
  10.   (amiga-menus menus))
  11.  
  12. (defun amiga-menus-dispatch (selection)
  13.   (let ((menu (car selection))
  14.     (item (cadr selection)))
  15.     (eval (cadr (nth item (cadr (nth menu amiga-menus-description)))))))
  16.  
  17. (defun make-explicit-string (str)
  18.   (if (and (>= (length str) 2) (= (elt str 0) 27) (< (elt str 1) 128))
  19.       (key-description (concat (char-to-string (+ 128 (elt str 1)))
  20.                    (substring str 2)))
  21.       (key-description str)))
  22.  
  23. (defun make-command-name (command str width)
  24.   (let ((keys (where-is-internal command nil t))
  25.     (string (if str str (symbol-name command))))
  26.     (if keys
  27.     (format (format "%%-%ds%%s" width) string (make-explicit-string keys))
  28.     string)))
  29.  
  30. (defun menu-items (commands)
  31.   (let* ((width 0)
  32.      (names (mapcar
  33.          (function (lambda (cmd)
  34.                  (if cmd
  35.                  (let* ((name (if (symbolp cmd)
  36.                           (symbol-name cmd)
  37.                           (car cmd)))
  38.                     (len (length name)))
  39.                    (if (> len width) (setq width len))
  40.                    name))))
  41.          commands)))
  42.     (mapcar
  43.      (function (lambda (cmd)
  44.          (let ((name (car names)))
  45.            (setq names (cdr names))
  46.            (if cmd
  47.                (let ((command (if (symbolp cmd) cmd (cadr cmd))))
  48.              (list (make-command-name command name (+ width 2))
  49.                    (list 'call-interactively (list 'quote command))
  50.                    (caddr cmd)))))))
  51.      commands)))
  52.  
  53.